home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / OPCODES.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  28.1 KB  |  728 lines
  1. ; OPCODES.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Primitive Functions and Opcodes                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 1 Apr 87:    pcs-primop-+, -* modified; no error was being signalled    *
  18. ;*        for a single non-numeric argument to either + or * since*
  19. ;*        pcs-primop-std-n2 assumes a unary arg is the operator's    *
  20. ;*        identity element and removes the operator; so, the    *
  21. ;*        arg was never type-checked since the operator's handler    *
  22. ;*        never got called; now force unarys to binarys to keep    *
  23. ;*        the operator (rb)                    *
  24. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  25. ;* -  8 Oct 93: Added vararg handler (lb)                *
  26. ;*                                    *
  27. ;*                    ``In nomine omnipotentii dei''    *
  28. ;************************************************************************
  29.  
  30. (define pcs-define-primop
  31.   (lambda (op handler)
  32.     (putprop op handler 'pcs*primop-handler)))
  33.  
  34.  
  35. (define (pcs-primop-std-n2 form)  ; n-ary to binary, left associative
  36.   (if (atom? form)
  37.       `(%%get-global%% (quote ,form))            ; funarg use
  38.       (begin
  39.     (pcs-chk-length>= form form 2)
  40.     (cond ((null? (cddr form))            ; unary?
  41.            (cadr form))                ; --> identity
  42.           ((null? (cdddr form))
  43.            form)                    ; binary
  44.           (else
  45.            (let ((op   (car form))
  46.              (a    (cadr form))
  47.              (b    (caddr form))
  48.              (rest (cdddr form)))
  49.          (pcs-primop-std-n2
  50.           `(,op (,op ,a ,b) . ,rest))))))))
  51.  
  52.  
  53. (define (pcs-primop-append* form)    ; for append, append!, string-append
  54.   (if (atom? form)
  55.       `(%%get-global%% (quote ,form))            ; funarg use
  56.       (let ((op (car form)))
  57.     (pcs-chk-length>= form form 1)
  58.     (cond ((null? (cdr form))            ; no args?
  59.            (if (eq? op 'STRING-APPEND)
  60.            ''""
  61.            ''()))
  62.           ((null? (cddr form))            ; one arg?
  63.            (if (eq? op 'STRING-APPEND)
  64.            `(STRING-APPEND ,(cadr form) '"")
  65.            (cadr form)))
  66.           ((null? (cdddr form))            ; two args?
  67.            (case op
  68.          ((APPEND) `(%APPEND . ,(cdr form)))
  69.          ((APPEND!) form)
  70.          (else (let ((a (gensym))
  71.                  (b (gensym)))
  72.              `(LET ((,a ,(cadr form))
  73.                 (,b ,(caddr form)))
  74.                 (%STRING-APPEND ,a 0 (STRING-LENGTH ,a)
  75.                         '()
  76.                         ,b 0 (STRING-LENGTH ,b)))))))
  77.           ((and (null? (cddddr form))
  78.             (eq? op 'STRING-APPEND))            ; 3 args
  79.            (let ((a (gensym))
  80.              (b (gensym))
  81.              (c (gensym)))
  82.          `(LET ((,a ,(cadr form))
  83.             (,b ,(caddr form))
  84.             (,c ,(cadddr form)))
  85.             (%STRING-APPEND ,a 0 (STRING-LENGTH ,a)
  86.                     ,b
  87.                     ,c 0 (STRING-LENGTH ,c)))))
  88.           (else
  89.            (let ((a (cadr form))
  90.              (b (caddr form))
  91.              (rest (cdddr form)))
  92.          (pcs-primop-append*
  93.           `(,op ,a (,op ,b . ,rest)))))))))
  94.  
  95.  
  96. (define pcs-primop-+                    ; "+" handler
  97.    (lambda (form)
  98.      (if (and (not (atom? form))
  99.           (null? (cdr form)))
  100.      0
  101.      (if (and (not (atom? form)) 
  102.                   (null? (cddr form)))
  103.          `(+ 0 ,(cadr form))
  104.          (pcs-primop-std-n2 form)))))
  105.  
  106.  
  107. (define pcs-primop--                    ; "-" handler
  108.    (lambda (form)
  109.      (cond ((and (not (atom? form))
  110.          (not (atom? (cdr form)))
  111.          (null? (cddr form)))
  112.         `(minus ,(cadr form)))
  113.        (else (pcs-primop-std-n2 form)))))
  114.  
  115.  
  116. (define pcs-primop-*                    ; "*" handler
  117.    (lambda (form)
  118.      (if (and (not (atom? form))
  119.           (null? (cdr form)))
  120.      1
  121.      (if (and (not (atom? form)) 
  122.                   (null? (cddr form)))
  123.          `(* 1 ,(cadr form))
  124.          (pcs-primop-std-n2 form)))))
  125.  
  126.  
  127. (define pcs-primop-/                    ; "/" handler
  128.    (lambda (form)
  129.      (cond ((and (not (atom? form))
  130.          (not (atom? (cdr form)))
  131.          (null? (cddr form)))
  132.         `(/ '1 ,(cadr form)))
  133.        (else (pcs-primop-std-n2 form)))))
  134.  
  135. (define pcs-primop-logical                ; <, >, <=, etc handler
  136.   (lambda (form)
  137.     (cond ((atom? form) `(%%get-global%% (quote ,form)))
  138.       ((null? (cddr form)) #T)
  139.       ((null? (cdddr form)) form)
  140.       (else (let ((op (car form)))
  141.           `(and ,(op ,(cadr form) ,(caddr form))
  142.             ,(op ,@(cddr form))))))))
  143.  
  144. (define (pcs-primop-vector form)            ; "vector" handler
  145.   (cond ((atom? form)
  146.      `(%%get-global%% (quote vector)))
  147.     (else
  148.      `(list->vector (list . ,(cdr form))))))
  149.  
  150.  
  151. (define (pcs-primop-list form)                ; "list" handler
  152.   (cond ((atom? form)
  153.      `(%%get-global%% (quote list)))
  154.     ((atom? (cdr form))     ; (list)
  155.      ''())
  156.     ((atom? (cddr form))     ; (list a)
  157.      form)
  158.     ((atom? (cdddr form))
  159.      (cons '%list2 (cdr form)))
  160.     (else
  161.      (let ((rest (pcs-primop-list (cons 'list (cddr form)))))
  162.        `(cons ,(cadr form) ,rest)))))
  163.  
  164.  
  165. (define (pcs-primop-list* form)             ; "list*" handler
  166.   (cond ((atom? form)
  167.      `(%%get-global%% (quote list*)))
  168.     ((atom? (cdr form))     ; (list*)
  169.      ''())
  170.     ((atom? (cddr form))     ; (list* a)
  171.      (cadr form))
  172.     (else
  173.      (let ((rest (pcs-primop-list* (cons 'list* (cddr form)))))
  174.        `(cons ,(cadr form) ,rest)))))
  175.  
  176.  
  177. (define pcs-primop-make-vector                ; "make-vector" handler
  178.   (lambda (form)
  179.     (cond ((atom? form)
  180.        `(%%get-global%% (quote ,form)))        ; funarg use
  181.       ((and (not (atom? (cdr form)))        ; unary?
  182.         (null? (cddr form)))
  183.        form)
  184.       ((and (not (atom? (cdr form)))        ; binary?
  185.         (not (atom? (cddr form)))
  186.         (null? (cdddr form)))
  187.        (let ((a (gensym)))
  188.          `(LET ((,a (MAKE-VECTOR ,(CADR FORM))))
  189.         (BEGIN (VECTOR-FILL! ,a ,(CADDR FORM))
  190.                ,a))))
  191.       (else
  192.        (pcs-chk-length= form form 3)))))
  193.  
  194.  
  195. (define pcs-primop-io-1                 ; optional PORT arg
  196.   (lambda (form)
  197.     (cond ((atom? form)
  198.        `(%%get-global%% (quote ,form)))        ; funarg use
  199.       ((null? (cdr form))
  200.        `(,(car form) '()))                          ; add null port
  201.       ((and (not (atom? (cdr form)))
  202.         (null? (cddr form)))
  203.        form)                    ; PORT supplied
  204.       (else
  205.        (pcs-chk-length= form form 2)))))
  206.  
  207. ;
  208. ;  Note that make-string uses the following primop definition to take
  209. ;  care of its optional second argument.
  210. ;
  211.  
  212. (define pcs-primop-io-2                 ; optional 2nd PORT arg
  213.   (lambda (form)
  214.     (cond ((atom? form)
  215.        `(%%get-global%% (quote ,form)))        ; funarg use
  216.       ((and (not (atom? (cdr form)))
  217.         (null? (cddr form)))            ; add null port
  218.        `(,(car form) ,(cadr form) '()))
  219.       ((and (not (atom? (cdr form)))
  220.         (not (atom? (cddr form)))
  221.         (null? (cdddr form)))
  222.        form)                    ; PORT supplied
  223.       (else
  224.        (pcs-chk-length= form form 3)))))
  225.  
  226. (define pcs-primop-vararg
  227.   (lambda (form)
  228.     (if (atom? form)
  229.     `(%%GET-GLOBAL%% (QUOTE ,form))            ; funarg use
  230.     form)))
  231.  
  232. ; --------------------------------------------------------------------
  233. ;
  234. ;                !! NOTE !!
  235. ;
  236. ;  Each primitive operation defined with PCS-DEFINE-PRIMOP must also
  237. ;  be represented at runtime as a closure object in case the name is
  238. ;  used as a "funarg."  The error handler can auto-create such
  239. ;  closures when both PCS*PRIMOP-HANDLER and PCS*OPCODE properties are
  240. ;  integers.    Others must have such closures defined explicitly.  Many
  241. ;  of them are defined in the PCS source file VARARGS.S.
  242. ;
  243. ; --------------------------------------------------------------------
  244.  
  245.  
  246. (begin
  247.  (pcs-define-primop  '%%bind-fluid%%     2)
  248.  (pcs-define-primop  '%%car              1)
  249.  (pcs-define-primop  '%%cdr              1)
  250.  (pcs-define-primop  '%%def-global%%     2)
  251.  (pcs-define-primop  '%%execute          1)
  252.  (pcs-define-primop  '%%fasl             1)
  253.  (pcs-define-primop  '%%fluid-bound?%%   1)
  254.  (pcs-define-primop  '%%get-fluid%%      1)
  255.  (pcs-define-primop  '%%get-global%%     1)
  256.  (pcs-define-primop  '%%get-scoops%%     1)
  257.  (pcs-define-primop  '%%set-fluid%%      2)
  258.  (pcs-define-primop  '%%set-global%%     2)
  259.  (pcs-define-primop  '%%set-scoops%%     2)
  260.  (pcs-define-primop  '%%unbind-fluid%%   1)
  261.  (pcs-define-primop  '%append            2)
  262.  (pcs-define-primop  '%apply             2)
  263.  (pcs-define-primop  '%begin-debug       0)
  264.  (pcs-define-primop  '%call/cc           1)
  265.  (pcs-define-primop  '%car               1)
  266.  (pcs-define-primop  '%cdr               1)
  267.  (pcs-define-primop  '%char-ready?       pcs-primop-io-1)
  268.  (pcs-define-primop  '%clear-registers   0)
  269.  (pcs-define-primop  '%clear-window      1)
  270.  (pcs-define-primop  '%close-port        1)
  271.  (pcs-define-primop  '%compact-memory    0)
  272.  (pcs-define-primop  '%define            3)
  273.  (pcs-define-primop  '%env-lu            2)
  274.  (pcs-define-primop  '%esc               pcs-primop-vararg)
  275.  (pcs-define-primop  '%garbage-collect   0)
  276.  (pcs-define-primop  '%get-history       1)
  277.  (pcs-define-primop  '%graphics          pcs-primop-vararg)
  278.  (pcs-define-primop  '%halt              1)
  279.  (pcs-define-primop  '%list2             2)
  280.  (pcs-define-primop  '%make-window       1)
  281.  (pcs-define-primop  '%mouse             pcs-primop-vararg)
  282.  (pcs-define-primop  '%open-port         2)
  283.  (pcs-define-primop  '%peek-char         pcs-primop-io-1)
  284.  (pcs-define-primop  '%port-get-attribute 2)
  285.  (pcs-define-primop  '%port-set-attribute! 3)
  286.  (pcs-define-primop  '%push-history      1)
  287.  (pcs-define-primop  '%random            0)
  288.  (pcs-define-primop  '%%read-char        pcs-primop-io-1)
  289.  (pcs-define-primop  '%read-line         pcs-primop-io-1)
  290.  (pcs-define-primop  '%reify             2)
  291.  (pcs-define-primop  '%reify!            3)
  292.  (pcs-define-primop  '%reify-port        2)
  293.  (pcs-define-primop  '%reify-port!       3)
  294.  (pcs-define-primop  '%reify-stack       1)
  295.  (pcs-define-primop  '%reify-stack!      2)
  296.  (pcs-define-primop  '%restore-window    2)
  297.  (pcs-define-primop  '%save-window       1)
  298.  (pcs-define-primop  '%set-global-environment 1)
  299.  (pcs-define-primop  '%sfpos             3)      ; set-file-position!
  300.  (pcs-define-primop  '%start-timer       1)
  301.  (pcs-define-primop  '%stop-timer        0)
  302.  (pcs-define-primop  '%string-append     7)
  303.  (pcs-define-primop  '%substring-display 5)
  304.  (pcs-define-primop  '%str-str           6)
  305.  (pcs-define-primop  '%transcript        1)
  306. )
  307.  
  308. (begin
  309.  (pcs-define-primop  '*          pcs-primop-*)
  310.  (pcs-define-primop  '+          pcs-primop-+)
  311.  (pcs-define-primop  '-          pcs-primop--)
  312.  (pcs-define-primop  '/          pcs-primop-/ )
  313.  (pcs-define-primop  '<          pcs-primop-logical)
  314.  (pcs-define-primop  '<=         pcs-primop-logical)
  315.  (pcs-define-primop  '=          pcs-primop-logical)
  316.  (pcs-define-primop  '>          pcs-primop-logical)
  317.  (pcs-define-primop  '>=         pcs-primop-logical)
  318.  (pcs-define-primop  '<>         pcs-primop-logical)
  319.  (pcs-define-primop  'abs        1)
  320.  (pcs-define-primop  'append     pcs-primop-append*)
  321.  (pcs-define-primop  'append!    pcs-primop-append*)
  322.  (pcs-define-primop  'assoc      2)
  323.  (pcs-define-primop  'assq       2)
  324.  (pcs-define-primop  'assv       2)
  325.  (pcs-define-primop  'atom?      1)
  326.  (pcs-define-primop  'bitwise-and pcs-primop-std-n2)
  327.  (pcs-define-primop  'bitwise-or  pcs-primop-std-n2)
  328.  (pcs-define-primop  'bitwise-xor pcs-primop-std-n2)
  329.  (pcs-define-primop  'caaar      1)
  330.  (pcs-define-primop  'caadr      1)
  331.  (pcs-define-primop  'caar       1)
  332.  (pcs-define-primop  'cadar      1)
  333.  (pcs-define-primop  'cadddr     1)
  334.  (pcs-define-primop  'caddr      1)
  335.  (pcs-define-primop  'cadr       1)
  336.  (pcs-define-primop  'car        1)
  337.  (pcs-define-primop  'cdaar      1)
  338.  (pcs-define-primop  'cdadr      1)
  339.  (pcs-define-primop  'cdar       1)
  340.  (pcs-define-primop  'cddar      1)
  341.  (pcs-define-primop  'cdddr      1)
  342.  (pcs-define-primop  'cddr       1)
  343.  (pcs-define-primop  'cdr        1)
  344.  (pcs-define-primop  'ceiling    1)
  345.  (pcs-define-primop  'char->integer 1)
  346.  (pcs-define-primop  'char-ci<?     2)
  347.  (pcs-define-primop  'char-ci=?     2)
  348.  (pcs-define-primop  'char-downcase 1)
  349.  (pcs-define-primop  'char-ready?   pcs-primop-io-1)
  350.  (pcs-define-primop  'char-upcase   1)
  351.  (pcs-define-primop  'char<?     2)
  352.  (pcs-define-primop  'char=?     2)
  353.  (pcs-define-primop  'char?      1)
  354.  (pcs-define-primop  'clear-history 0)
  355.  (pcs-define-primop  'closure?   1)
  356.  (pcs-define-primop  'complex?   1)
  357.  (pcs-define-primop  'cons       2)
  358.  (pcs-define-primop  'continuation?  1)
  359.  (pcs-define-primop  'display    pcs-primop-io-2)
  360.  (pcs-define-primop  'divide     2)
  361.  (pcs-define-primop  'environment-parent 1)
  362.  (pcs-define-primop  'environment?       1)
  363.  (pcs-define-primop  'eq?        2)
  364.  (pcs-define-primop  'equal?     2)
  365.  (pcs-define-primop  'eqv?       2)
  366.  (pcs-define-primop  'even?      1)
  367.  (pcs-define-primop  'float      1)
  368.  (pcs-define-primop  'float?     1)
  369.  (pcs-define-primop  'floor      1)
  370.  (pcs-define-primop  'getprop    2)
  371.  (pcs-define-primop  'integer->char  1)
  372.  (pcs-define-primop  'integer?   1)
  373.  (pcs-define-primop  'last-pair  1)
  374.  (pcs-define-primop  'length     1)
  375.  (pcs-define-primop  'list       pcs-primop-list)
  376.  (pcs-define-primop  'list*      pcs-primop-list*)
  377.  (pcs-define-primop  'list-tail  2)
  378.  (pcs-define-primop  'make-packed-vector 3)
  379.  (pcs-define-primop  'make-port          2)
  380.  (pcs-define-primop  'make-string pcs-primop-io-2) ; handle optional 2nd arg
  381.  (pcs-define-primop  'make-vector         pcs-primop-make-vector)
  382.  (pcs-define-primop  'max        pcs-primop-std-n2)
  383.  (pcs-define-primop  'member     2)
  384.  (pcs-define-primop  'memq       2)
  385.  (pcs-define-primop  'memv       2)
  386.  (pcs-define-primop  'min        pcs-primop-std-n2)
  387.  (pcs-define-primop  'minus      1)
  388.  (pcs-define-primop  'modulo     2)
  389.  (pcs-define-primop  'negative?  1)
  390.  (pcs-define-primop  'newline    pcs-primop-io-1)
  391.  (pcs-define-primop  'not        1)
  392.  (pcs-define-primop  'number?    1)
  393.  (pcs-define-primop  'object-hash        1)
  394.  (pcs-define-primop  'object-unhash      1)
  395.  (pcs-define-primop  'odd?       1)
  396.  (pcs-define-primop  'pair?      1)
  397.  (pcs-define-primop  'port?      1)
  398.  (pcs-define-primop  'positive?  1)
  399.  (pcs-define-primop  'prin1      pcs-primop-io-2)
  400.  (pcs-define-primop  'princ      pcs-primop-io-2)
  401.  (pcs-define-primop  'print      pcs-primop-io-2)
  402.  (pcs-define-primop  'print-length  1)
  403.  (pcs-define-primop  'proc?      1)
  404.  (pcs-define-primop  'proplist   1)
  405.  (pcs-define-primop  'putprop    3)
  406.  (pcs-define-primop  'quotient   2)
  407.  (pcs-define-primop  'rational?  1)
  408.  (pcs-define-primop  'read-line  pcs-primop-io-1)
  409.  (pcs-define-primop  'read-atom  pcs-primop-io-1)
  410.  (pcs-define-primop  '%read-char 1)
  411.  (pcs-define-primop  'real?      1)
  412.  (pcs-define-primop  'remainder  2)
  413.  (pcs-define-primop  'remprop    2)
  414.  (pcs-define-primop  'reset      0)
  415.  (pcs-define-primop  '%reverse!  1)
  416.  (pcs-define-primop  'round      1)
  417.  (pcs-define-primop  'scheme-reset  0)
  418.  (pcs-define-primop  'set-car!   2)
  419.  (pcs-define-primop  'set-cdr!   2)
  420.  (pcs-define-primop  'string->symbol     1)
  421.  (pcs-define-primop  'string->uninterned-symbol  1)
  422.  (pcs-define-primop  'string-append      pcs-primop-append*)
  423.  (pcs-define-primop  'string-fill!       2)
  424.  (pcs-define-primop  'string-length      1)
  425.  (pcs-define-primop  'string-ref         2)
  426.  (pcs-define-primop  'string-set!        3)
  427.  (pcs-define-primop  'string?    1)
  428.  (pcs-define-primop  'substring  3)
  429.  (pcs-define-primop  'substring-find-next-char-in-set     4)
  430.  (pcs-define-primop  'substring-find-previous-char-in-set 4)
  431.  (pcs-define-primop  'symbol->string     1)
  432.  (pcs-define-primop  'symbol?    1)
  433.  (pcs-define-primop  'the-environment    0)
  434.  (pcs-define-primop  '%make-hashed-environment 0)
  435.  (pcs-define-primop  'truncate   1)
  436.  (pcs-define-primop  'unread-char  pcs-primop-io-1)
  437.  (pcs-define-primop  'vector     pcs-primop-vector)
  438.  (pcs-define-primop  'vector-fill!  2)
  439.  (pcs-define-primop  'vector-length   1)
  440.  (pcs-define-primop  'vector-ref         2)
  441.  (pcs-define-primop  'vector-set! 3)
  442.  (pcs-define-primop  'vector?    1)
  443.  (pcs-define-primop  'window-save-contents     1)
  444.  (pcs-define-primop  'window-restore-contents  2)
  445.  (pcs-define-primop  'write      pcs-primop-io-2)
  446.  (pcs-define-primop  'write-char pcs-primop-io-2)
  447.  (pcs-define-primop  'zero?      1)
  448.  )
  449.  
  450.  
  451. ; --------------------------------------------------------------------
  452.  
  453.  
  454. (define pcs-define-opcode            ;    !! NOTE !!
  455.   (lambda (op opcode)                ; negative values mark
  456.     (putprop op opcode 'pcs*opcode)))           ; side-effecting operations
  457.  
  458. ;        -- opcode assignments --
  459.  
  460. (begin
  461.  (pcs-define-opcode  '%%car              064)    ; (%%car nil) => nil
  462.  (pcs-define-opcode  '%%cdr              065)    ; (%%cdr nil) => nil
  463.  (pcs-define-opcode  '%%fasl            -191)
  464.  (pcs-define-opcode  '%*imm              084)
  465.  (pcs-define-opcode  '%+imm              081)
  466.  (pcs-define-opcode  '%/imm              086)
  467.  (pcs-define-opcode  '%append            113)
  468.  (pcs-define-opcode  '%apply            -056)
  469.  (pcs-define-opcode  '%call/cc          -054)
  470.  (pcs-define-opcode  '%car               089)    ; (%car nil) => #!unbound
  471.  (pcs-define-opcode  '%cdr               090)    ; (%cdr nil) => #!unbound
  472.  (pcs-define-opcode  '%char-ready       -245)
  473.  (pcs-define-opcode  '%clear-window     -211)
  474.  (pcs-define-opcode  '%close-port       -177)
  475.  (pcs-define-opcode  '%define           -220)
  476.  (pcs-define-opcode  '%env-lu            219)
  477.  (pcs-define-opcode  '%esc              -232)
  478.  (pcs-define-opcode  '%get-history      -183)
  479.  (pcs-define-opcode  '%graphics         -215)
  480.  (pcs-define-opcode  '%halt             -248)
  481.  (pcs-define-opcode  '%list2             120)
  482.  (pcs-define-opcode  '%make-window      -208)
  483.  (pcs-define-opcode  '%mouse            -233)
  484.  (pcs-define-opcode  '%open-port        -176)
  485.  (pcs-define-opcode  '%peek-char        -246)
  486.  (pcs-define-opcode  '%port-get-attribute  -241)
  487.  (pcs-define-opcode  '%port-set-attribute! -242)
  488.  (pcs-define-opcode  '%push-history     -182)
  489.  (pcs-define-opcode  '%random           -091)
  490.  (pcs-define-opcode  '%%read-char       -243)
  491.  (pcs-define-opcode  '%read-line        -244)
  492.  (pcs-define-opcode  '%reify             216)
  493.  (pcs-define-opcode  '%reify!           -226)
  494.  (pcs-define-opcode  '%reify-port        210)
  495.  (pcs-define-opcode  '%reify-port!      -209)
  496.  (pcs-define-opcode  '%reify-stack       229)
  497.  (pcs-define-opcode  '%reify-stack!     -230)
  498.  (pcs-define-opcode  '%restore-window   -213)
  499.  (pcs-define-opcode  '%save-window      -212)
  500.  (pcs-define-opcode  '%set-global-environment -225)
  501.  (pcs-define-opcode  '%sfpos            -231)     ; set-file-position!
  502.  (pcs-define-opcode  '%start-timer      -174)
  503.  (pcs-define-opcode  '%stop-timer       -175)
  504.  (pcs-define-opcode  '%string-append     214)
  505.  (pcs-define-opcode  '%substring-display   -172)
  506.  (pcs-define-opcode  '%str-str         162)
  507.  (pcs-define-opcode  '%transcript       -189)
  508. )
  509. (begin
  510.  (pcs-define-opcode  '*                  083)
  511.  (pcs-define-opcode  '+                  080)
  512.  (pcs-define-opcode  '-                  082)
  513.  (pcs-define-opcode  '/                  085)
  514.  (pcs-define-opcode  '<                  092)
  515.  (pcs-define-opcode  '<=                 093)
  516.  (pcs-define-opcode  '=                  094)
  517.  (pcs-define-opcode  '>                  095)
  518.  (pcs-define-opcode  '>=                 096)
  519.  (pcs-define-opcode  '<>                 097)
  520.  (pcs-define-opcode  'abs                149)
  521.  (pcs-define-opcode  'append!           -112)
  522.  (pcs-define-opcode  'assoc              110)
  523.  (pcs-define-opcode  'assq               108)
  524.  (pcs-define-opcode  'assv               109)
  525.  (pcs-define-opcode  'atom?              128)
  526.  (pcs-define-opcode  'bitwise-xor        125)
  527.  (pcs-define-opcode  'bitwise-and        126)
  528.  (pcs-define-opcode  'bitwise-or         127)
  529.  (pcs-define-opcode  'caaar              070)
  530.  (pcs-define-opcode  'caadr              071)
  531.  (pcs-define-opcode  'caar               066)
  532.  (pcs-define-opcode  'cadar              072)
  533.  (pcs-define-opcode  'cadddr             078)
  534.  (pcs-define-opcode  'caddr              073)
  535.  (pcs-define-opcode  'cadr               067)
  536.  (pcs-define-opcode  'car                064)    ; same as %%car
  537.  (pcs-define-opcode  'cdaar              074)
  538.  (pcs-define-opcode  'cdadr              075)
  539.  (pcs-define-opcode  'cdar               068)
  540.  (pcs-define-opcode  'cddar              076)
  541.  (pcs-define-opcode  'cdddr              077)
  542.  (pcs-define-opcode  'cddr               069)
  543.  (pcs-define-opcode  'cdr                065)    ; same as %%cdr
  544.  (pcs-define-opcode  'ceiling            153)
  545.  (pcs-define-opcode  'char->integer      161)
  546.  (pcs-define-opcode  'char-ci<?          195)
  547.  (pcs-define-opcode  'char-ci=?          193)
  548.  (pcs-define-opcode  'char-downcase      197)
  549.  (pcs-define-opcode  'char-ready?        190)
  550.  (pcs-define-opcode  'char-upcase        196)
  551.  (pcs-define-opcode  'char<?             194)
  552.  (pcs-define-opcode  'char=?             192)
  553.  (pcs-define-opcode  'char?              156)
  554.  (pcs-define-opcode  'clear-history     -185)
  555.  (pcs-define-opcode  'closure?           129)
  556.  (pcs-define-opcode  'complex?           137)   ; same as NUMBER?
  557.  (pcs-define-opcode  'cons               079)
  558.  (pcs-define-opcode  'continuation?      131)
  559.  (pcs-define-opcode  'display           -179)
  560.  (pcs-define-opcode  'divide         123)
  561.  (pcs-define-opcode  'environment-parent 218)
  562.  (pcs-define-opcode  'environment?       157)
  563.  (pcs-define-opcode  'eq?                100)
  564.  (pcs-define-opcode  'equal?             102)
  565.  (pcs-define-opcode  'eqv?               101)
  566.  (pcs-define-opcode  'even?              132)
  567.  (pcs-define-opcode  'float              150)
  568.  (pcs-define-opcode  'float?             133)
  569.  (pcs-define-opcode  'floor              152)
  570.  (pcs-define-opcode  'getprop            116)
  571.  (pcs-define-opcode  'integer->char      160)
  572.  (pcs-define-opcode  'integer?           135)
  573.  (pcs-define-opcode  'last-pair          166)
  574.  (pcs-define-opcode  'length             165)
  575.  (pcs-define-opcode  'list               111)
  576.  (pcs-define-opcode  'list-tail         122)
  577.  (pcs-define-opcode  'make-packed-vector 171)
  578.  (pcs-define-opcode  'make-port         -240)
  579.  (pcs-define-opcode  'make-string        201)
  580.  (pcs-define-opcode  'make-vector        168)
  581.  (pcs-define-opcode  'max                098)
  582.  (pcs-define-opcode  'member             105)
  583.  (pcs-define-opcode  'memq               103)
  584.  (pcs-define-opcode  'memv               104)
  585.  (pcs-define-opcode  'min                099)
  586.  (pcs-define-opcode  'minus              151)
  587.  (pcs-define-opcode  'modulo         124)
  588.  (pcs-define-opcode  'negative?          147)
  589.  (pcs-define-opcode  'newline           -181)
  590.  (pcs-define-opcode  'not                136)
  591.  (pcs-define-opcode  'number?            137)
  592.  (pcs-define-opcode  'object-hash       -227)
  593.  (pcs-define-opcode  'object-unhash      228)
  594.  (pcs-define-opcode  'odd?               138)
  595.  (pcs-define-opcode  'pair?              139)
  596.  (pcs-define-opcode  'port?              140)
  597.  (pcs-define-opcode  'positive?          148)
  598.  (pcs-define-opcode  'prin1             -178)
  599.  (pcs-define-opcode  'princ             -179)
  600.  (pcs-define-opcode  'print             -180)
  601.  (pcs-define-opcode  'print-length       184)
  602.  (pcs-define-opcode  'proc?              141)
  603.  (pcs-define-opcode  'proplist           118)
  604.  (pcs-define-opcode  'putprop           -117)
  605.  (pcs-define-opcode  'quotient           087)
  606.  (pcs-define-opcode  'rational?          135)   ; same as INTEGER?
  607.  (pcs-define-opcode  'read-line         -186)
  608.  (pcs-define-opcode  'read-atom         -187)
  609.  (pcs-define-opcode  '%read-char        -188)
  610.  (pcs-define-opcode  'real?              137)   ; same as NUMBER?
  611.  (pcs-define-opcode  'remainder          088)
  612.  (pcs-define-opcode  'remprop           -119)
  613.  (pcs-define-opcode  'reset             -251)
  614.  (pcs-define-opcode  '%reverse!         -106)
  615.  (pcs-define-opcode  'round              155)
  616.  (pcs-define-opcode  'scheme-reset      -252)
  617.  (pcs-define-opcode  'set-car!          -020)
  618.  (pcs-define-opcode  'set-cdr!          -021)
  619.  (pcs-define-opcode  'string->symbol     203)
  620.  (pcs-define-opcode  'string->uninterned-symbol  204)
  621.  (pcs-define-opcode  'string-fill!      -202)
  622.  (pcs-define-opcode  'string-length      198)
  623.  (pcs-define-opcode  'string-ref         199)
  624.  (pcs-define-opcode  'string-set!       -200)
  625.  (pcs-define-opcode  'string?            143)
  626.  (pcs-define-opcode  'substring          167)
  627.  (pcs-define-opcode  'substring-find-next-char-in-set     206)
  628.  (pcs-define-opcode  'substring-find-previous-char-in-set 207)
  629.  (pcs-define-opcode  'symbol->string     205)
  630.  (pcs-define-opcode  'symbol?            144)
  631.  (pcs-define-opcode  'the-environment    217)
  632.  (pcs-define-opcode  '%make-hashed-environment 62)
  633.  (pcs-define-opcode  'truncate           154)
  634.  (pcs-define-opcode  'unread-char       -173)
  635.  (pcs-define-opcode  'vector-fill!      -170)
  636.  (pcs-define-opcode  'vector-length      169)
  637.  (pcs-define-opcode  'vector-ref         011)
  638.  (pcs-define-opcode  'vector-set!       -019)
  639.  (pcs-define-opcode  'vector?            145)
  640.  (pcs-define-opcode  'window-save-contents     -212)
  641.  (pcs-define-opcode  'window-restore-contents  -213)
  642.  (pcs-define-opcode  'write             -178)
  643.  (pcs-define-opcode  'write-char        -179)
  644.  (pcs-define-opcode  'zero?              146)
  645.  )
  646. ; --------------------------------------------------------------------
  647.  
  648. (begin
  649.  (pcs-define-opcode  'LOAD                000)
  650.  (pcs-define-opcode  'LOAD-CONSTANT       001)
  651.  (pcs-define-opcode  'LOAD-IMMEDIATE      002)
  652.  (pcs-define-opcode  'LOAD-LOCAL          004)
  653.  (pcs-define-opcode  'LOAD-LEX            005)
  654.  (pcs-define-opcode  'LOAD-ENV            006)
  655.  (pcs-define-opcode  'LOAD-GLOBAL         007)
  656.  (pcs-define-opcode  'LOAD-FLUID          008)
  657.  
  658.  (pcs-define-opcode  'STORE-LOCAL        -012)
  659.  (pcs-define-opcode  'STORE-LEX          -013)
  660.  (pcs-define-opcode  'STORE-ENV          -014)
  661.  (pcs-define-opcode  'STORE-GLOBAL       -015)
  662.  (pcs-define-opcode  'STORE-GLOBAL-DEF   -031)
  663.  (pcs-define-opcode  'STORE-FLUID        -016)
  664.  
  665.  (pcs-define-opcode  'POP                -024)
  666.  (pcs-define-opcode  'PUSH               -025)
  667.  (pcs-define-opcode  'DROP               -026)
  668.  (pcs-define-opcode  'DROP-ENV           -061)
  669.  (pcs-define-opcode  'PUSH-ENV           -221)
  670.  (pcs-define-opcode  'BIND-FLUID         -029)
  671.  (pcs-define-opcode  'UNBIND-FLUIDS      -030)
  672.  (pcs-define-opcode  '%%fluid-bound?%%    134)
  673.  
  674.  (pcs-define-opcode  'J_S                -032)
  675.  (pcs-define-opcode  'JN_S               -034)
  676.  (pcs-define-opcode  'JNN_S              -036)
  677.  (pcs-define-opcode  'JA_S               -038)
  678.  (pcs-define-opcode  'JNA_S              -040)
  679.  (pcs-define-opcode  'JE_S               -042)
  680.  (pcs-define-opcode  'JNE_S              -044)
  681.  
  682.  (pcs-define-opcode  'J_L                -033)
  683.  (pcs-define-opcode  'JN_L               -035)
  684.  (pcs-define-opcode  'JNN_L              -037)
  685.  (pcs-define-opcode  'JA_L               -039)
  686.  (pcs-define-opcode  'JNA_L              -041)
  687.  (pcs-define-opcode  'JE_L               -043)
  688.  (pcs-define-opcode  'JNE_L              -045)
  689.  
  690.  (pcs-define-opcode  'CALL               -048)
  691.  (pcs-define-opcode  'CALL-TR            -049)
  692.  (pcs-define-opcode  'CCC                -050)
  693.  (pcs-define-opcode  'CCC-TR             -051)
  694.  (pcs-define-opcode  'CALL-CLOSURE       -052)
  695.  (pcs-define-opcode  'CALL-CLOSURE-TR    -053)
  696.  (pcs-define-opcode  'CCC-CLOSED         -054)
  697.  (pcs-define-opcode  'CCC-CLOSED-TR      -055)
  698.  (pcs-define-opcode  'APPLY-CLOSURE      -056)
  699.  (pcs-define-opcode  'APPLY-CLOSURE-TR   -057)
  700.  
  701.  (pcs-define-opcode  'EXIT               -059)
  702.  (pcs-define-opcode  'CLOSE              -060)
  703.  
  704.  (pcs-define-opcode  '%begin-debug       -255)
  705.  (pcs-define-opcode  '%clear-registers   -253)
  706.  (pcs-define-opcode  '%compact-memory    -247)
  707.  (pcs-define-opcode  '%%execute          -058)
  708.  (pcs-define-opcode  '%garbage-collect   -249)
  709.  )
  710. ; --------------------------------------------------------------------
  711.  
  712. (begin
  713.  (putprop '%begin-debug     #T 'pcs*nilargop)    ; no source or dest
  714.  (putprop '%clear-registers #T 'pcs*nilargop)    ; no source or dest
  715.  (putprop '%compact-memory  #T 'pcs*nilargop)    ; no source or dest
  716.  (putprop '%garbage-collect #T 'pcs*nilargop)    ; no source or dest
  717.  (putprop 'clear-history    #T 'pcs*nilargop)    ; no source or dest
  718.  (putprop 'reset            #T 'pcs*nilargop)    ; no source or dest
  719.  (putprop 'scheme-reset     #T 'pcs*nilargop)    ; no source or dest
  720.  )
  721. ; --------------------------------------------------------------------
  722.  
  723. (begin                            ; collect garbage
  724.  (%clear-registers)
  725.  (%compact-memory))
  726.  
  727. ; --------------------------------------------------------------------
  728.